home *** CD-ROM | disk | FTP | other *** search
/ Gigarom 1 / Gigarom Macintosh Archives (Quantum Leap)(CDRM1080320)(1993).iso / FILES / DEV / I-Z / Xlisp_Source.cpt / xleval.c < prev    next >
Text File  |  1980-01-01  |  8KB  |  352 lines
  1. /* xleval - xlisp evaluator */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *xlstack,*xlenv,*xlnewenv;
  7. extern NODE *s_lambda,*s_macro;
  8. extern NODE *k_optional,*k_rest,*k_aux;
  9. extern NODE *s_evalhook,*s_applyhook;
  10. extern NODE *s_unbound;
  11. extern NODE *s_stdout;
  12.  
  13. /* forward declarations */
  14. FORWARD NODE *xlxeval();
  15. FORWARD NODE *evalhook();
  16. FORWARD NODE *evform();
  17. FORWARD NODE *evsym();
  18. FORWARD NODE *evfun();
  19.  
  20. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  21. NODE *xleval(expr)
  22.   NODE *expr;
  23. {
  24.     return (s_evalhook->n_symvalue ? evalhook(expr) : xlxeval(expr));
  25. }
  26.  
  27. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  28. NODE *xlxeval(expr)
  29.   NODE *expr;
  30. {
  31. #ifdef MEGAMAX
  32.     macidle();
  33. #endif
  34.  
  35.     /* evaluate nil to itself */
  36.     if (expr == NIL)
  37.     return (NIL);
  38.  
  39.     /* add trace entry */
  40.     xltpush(expr);
  41.  
  42.     /* check type of value */
  43.     if (consp(expr))
  44.     expr = evform(expr);
  45.     else if (symbolp(expr))
  46.     expr = evsym(expr);
  47.  
  48.     /* remove trace entry */
  49.     xltpop();
  50.  
  51.     /* return the value */
  52.     return (expr);
  53. }
  54.  
  55. /* xlapply - apply a function to a list of arguments */
  56. NODE *xlapply(fun,args)
  57.   NODE *fun,*args;
  58. {
  59.     NODE *val;
  60.  
  61. #ifdef MEGAMAX
  62.     macidle();
  63. #endif
  64.  
  65.     /* check for a null function */
  66.     if (fun == NIL)
  67.     xlfail("bad function");
  68.  
  69.     /* evaluate the function */
  70.     if (subrp(fun))
  71.     val = (*fun->n_subr)(args);
  72.     else if (consp(fun)) {
  73.     if (car(fun) != s_lambda)
  74.         xlfail("bad function type");
  75.     val = evfun(fun,args);
  76.     }
  77.     else
  78.     xlfail("bad function");
  79.  
  80.     /* return the result value */
  81.     return (val);
  82. }
  83.  
  84. /* evform - evaluate a form */
  85. LOCAL NODE *evform(expr)
  86.   NODE *expr;
  87. {
  88.     NODE *oldstk,fun,args,*val,*type;
  89.  
  90.     /* create a stack frame */
  91.     oldstk = xlsave(&fun,&args,NULL);
  92.  
  93.     /* get the function and the argument list */
  94.     fun.n_ptr = car(expr);
  95.     args.n_ptr = cdr(expr);
  96.  
  97.     /* evaluate the first expression */
  98.     if ((fun.n_ptr = xleval(fun.n_ptr)) == NIL)
  99.     xlfail("bad function");
  100.  
  101.     /* evaluate the function */
  102.     if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
  103.     if (subrp(fun.n_ptr))
  104.         args.n_ptr = xlevlist(args.n_ptr);
  105.     val = (*fun.n_ptr->n_subr)(args.n_ptr);
  106.     }
  107.     else if (consp(fun.n_ptr)) {
  108.     if ((type = car(fun.n_ptr)) == s_lambda) {
  109.         args.n_ptr = xlevlist(args.n_ptr);
  110.         val = evfun(fun.n_ptr,args.n_ptr);
  111.     }
  112.     else if (type == s_macro) {
  113.         args.n_ptr = evfun(fun.n_ptr,args.n_ptr);
  114.         val = xleval(args.n_ptr);
  115.     }
  116.     else
  117.         xlfail("bad function type");
  118.     }
  119.     else if (objectp(fun.n_ptr))
  120.     val = xlsend(fun.n_ptr,args.n_ptr);
  121.     else
  122.     xlfail("bad function");
  123.  
  124.     /* restore the previous stack frame */
  125.     xlstack = oldstk;
  126.  
  127.     /* return the result value */
  128.     return (val);
  129. }
  130.  
  131. /* evalhook - call the evalhook function */
  132. LOCAL NODE *evalhook(expr)
  133.   NODE *expr;
  134. {
  135.     NODE *oldstk,*oldenv,fun,args,*val;
  136.  
  137.     /* create a new stack frame */
  138.     oldstk = xlsave(&fun,&args,NULL);
  139.  
  140.     /* get the hook function */
  141.     fun.n_ptr = s_evalhook->n_symvalue;
  142.  
  143.     /* make an argument list */
  144.     args.n_ptr = newnode(LIST);
  145.     rplaca(args.n_ptr,expr);
  146.  
  147.     /* rebind the hook functions to nil */
  148.     oldenv = xlenv;
  149.     xlsbind(s_evalhook,NIL);
  150.     xlsbind(s_applyhook,NIL);
  151.  
  152.     /* call the hook function */
  153.     val = xlapply(fun.n_ptr,args.n_ptr);
  154.  
  155.     /* unbind the symbols */
  156.     xlunbind(oldenv);
  157.  
  158.     /* restore the previous stack frame */
  159.     xlstack = oldstk;
  160.  
  161.     /* return the value */
  162.     return (val);
  163. }
  164.  
  165. /* xlevlist - evaluate a list of arguments */
  166. NODE *xlevlist(args)
  167.   NODE *args;
  168. {
  169.     NODE *oldstk,src,dst,*new,*last,*val;
  170.  
  171.     /* create a stack frame */
  172.     oldstk = xlsave(&src,&dst,NULL);
  173.  
  174.     /* initialize */
  175.     src.n_ptr = args;
  176.  
  177.     /* evaluate each argument */
  178.     for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {
  179.  
  180.     /* check this entry */
  181.     if (!consp(src.n_ptr))
  182.         xlfail("bad argument list");
  183.  
  184.     /* allocate a new list entry */
  185.     new = newnode(LIST);
  186.     if (val)
  187.         rplacd(last,new);
  188.     else
  189.         val = dst.n_ptr = new;
  190.     rplaca(new,xleval(car(src.n_ptr)));
  191.     last = new;
  192.     }
  193.  
  194.     /* restore the previous stack frame */
  195.     xlstack = oldstk;
  196.  
  197.     /* return the new list */
  198.     return (val);
  199. }
  200.  
  201. /* evsym - evaluate a symbol */
  202. LOCAL NODE *evsym(sym)
  203.   NODE *sym;
  204. {
  205.     NODE *p;
  206.  
  207.     /* check for a reference to an instance variable */
  208.     if ((p = xlobsym(sym)) != NIL)
  209.     return (car(p));
  210.  
  211.     /* get the value of the variable */
  212.     while ((p = sym->n_symvalue) == s_unbound)
  213.     xlunbound(sym);
  214.  
  215.     /* return the value */
  216.     return (p);
  217. }
  218.  
  219. /* xlunbound - signal an unbound variable error */
  220. xlunbound(sym)
  221.   NODE *sym;
  222. {
  223.     xlcerror("try evaluating symbol again","unbound variable",sym);
  224. }
  225.  
  226. /* evfun - evaluate a function */
  227. LOCAL NODE *evfun(fun,args)
  228.   NODE *fun,*args;
  229. {
  230.     NODE *oldstk,*oldenv,*oldnewenv,cptr,*fargs,*val;
  231.  
  232.     /* create a stack frame */
  233.     oldstk = xlsave(&cptr,NULL);
  234.  
  235.     /* skip the function type */
  236.     if ((fun = cdr(fun)) == NIL || !consp(fun))
  237.     xlfail("bad function definition");
  238.  
  239.     /* get the formal argument list */
  240.     if ((fargs = car(fun)) && !consp(fargs))
  241.     xlfail("bad formal argument list");
  242.  
  243.     /* bind the formal parameters */
  244.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  245.     xlabind(fargs,args);
  246.     xlfixbindings();
  247.  
  248.     /* execute the code */
  249.     for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
  250.     val = xlevarg(&cptr.n_ptr);
  251.  
  252.     /* restore the environment */
  253.     xlunbind(oldenv); xlnewenv = oldnewenv;
  254.  
  255.     /* restore the previous stack frame */
  256.     xlstack = oldstk;
  257.  
  258.     /* return the result value */
  259.     return (val);
  260. }
  261.  
  262. /* xlabind - bind the arguments for a function */
  263. xlabind(fargs,aargs)
  264.   NODE *fargs,*aargs;
  265. {
  266.     NODE *arg;
  267.  
  268.     /* evaluate and bind each required argument */
  269.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  270.  
  271.     /* bind the formal variable to the argument value */
  272.     xlbind(arg,car(aargs));
  273.  
  274.     /* move the argument list pointers ahead */
  275.     fargs = cdr(fargs);
  276.     aargs = cdr(aargs);
  277.     }
  278.  
  279.     /* check for the '&optional' keyword */
  280.     if (consp(fargs) && car(fargs) == k_optional) {
  281.     fargs = cdr(fargs);
  282.  
  283.     /* bind the arguments that were supplied */
  284.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  285.  
  286.         /* bind the formal variable to the argument value */
  287.         xlbind(arg,car(aargs));
  288.  
  289.         /* move the argument list pointers ahead */
  290.         fargs = cdr(fargs);
  291.         aargs = cdr(aargs);
  292.     }
  293.  
  294.     /* bind the rest to nil */
  295.     while (consp(fargs) && !iskeyword(arg = car(fargs))) {
  296.  
  297.         /* bind the formal variable to nil */
  298.         xlbind(arg,NIL);
  299.  
  300.         /* move the argument list pointer ahead */
  301.         fargs = cdr(fargs);
  302.     }
  303.     }
  304.  
  305.     /* check for the '&rest' keyword */
  306.     if (consp(fargs) && car(fargs) == k_rest) {
  307.     fargs = cdr(fargs);
  308.     if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
  309.         xlbind(arg,aargs);
  310.     else
  311.         xlfail("symbol missing after &rest");
  312.     fargs = cdr(fargs);
  313.     aargs = NIL;
  314.     }
  315.  
  316.     /* check for the '&aux' keyword */
  317.     if (consp(fargs) && car(fargs) == k_aux)
  318.     while ((fargs = cdr(fargs)) != NIL && consp(fargs))
  319.         xlbind(car(fargs),NIL);
  320.  
  321.     /* make sure the correct number of arguments were supplied */
  322.     if (fargs != aargs)
  323.     xlfail(fargs ? "too few arguments" : "too many arguments");
  324. }
  325.  
  326. /* iskeyword - check to see if a symbol is a keyword */
  327. LOCAL int iskeyword(sym)
  328.   NODE *sym;
  329. {
  330.     return (sym == k_optional || sym == k_rest || sym == k_aux);
  331. }
  332.  
  333. /* xlsave - save nodes on the stack */
  334. NODE *xlsave(n)
  335.   NODE *n;
  336. {
  337.     NODE **nptr,*oldstk;
  338.  
  339.     /* save the old stack pointer */
  340.     oldstk = xlstack;
  341.  
  342.     /* save each node */
  343.     for (nptr = &n; *nptr != NULL; nptr++) {
  344.     rplaca(*nptr,NIL);
  345.     rplacd(*nptr,xlstack);
  346.     xlstack = *nptr;
  347.     }
  348.  
  349.     /* return the old stack pointer */
  350.     return (oldstk);
  351. }
  352.